home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / zebu v3.3.3 (LALR parser) / zebra-debug.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  2.8 KB  |  74 lines  |  [TEXT/ttxt]
  1. ; -*- mode:     CL -*- ----------------------------------------------------- ;
  2. ; File:         zebra-debug.lisp
  3. ; Description:  Translating KB-Objects into readable lists 
  4. ; Author:       Karsten Konrad
  5. ; Created:       6-Apr-93
  6. ; Modified:     Mon Aug  9 16:26:52 1993 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      ZEBU
  9. ; Status:       Experimental (Do Not Distribute) 
  10. ; RCS $Header: $
  11. ;
  12. ; (c) Copyright 1993, Hewlett-Packard Company
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; Revisions:
  15. ; RCS $Log: $
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17. (in-package "ZEBU")
  18. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19. ;;                      PostScript Graph of the Kb-domain
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21. ;; psgraph (from CMU) and Ghostview from FSF are needed
  22.  
  23. (defun show-kb-hierarchy (&optional (file "/tmp/kb-classes.ps"))
  24.   (let ((start 'kb-domain))
  25.     (with-open-file (*standard-output* file :direction :output)
  26.       (psgraph start 
  27.            #'zb:KB-subtypes
  28.            #'(lambda (x) (list (string x)))
  29.            t nil #'eq))
  30.     (shell (format
  31.         nil
  32.         "ghostview -display ~a -notitle -nolabels -nolocator ~a &"
  33.         (environment-variable "DISPLAY") file))))
  34.  
  35. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36. ; Als Zugabe eine Funktion, die ein Kb-Objekt in eine vollstaendige
  37. ; Liste uebersetzt; man sieht dann mal, was alles in der Struktur
  38. ; steht. Vor allem zum Debuggen von Transformationen ist das
  39. ; sehr hilfreich.
  40.  
  41. (require "zebu-kb-domain")
  42. (require "zebu-tree-attributes")
  43.  
  44. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  45. ;;; Translating KB-Objects into readable lists 
  46. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47.  
  48. (defun kb-tree2list (kb-object)
  49.   "translates a kb-object to a list which should contain all
  50.    all relevant information."
  51.   (cond ((kb-domain-p kb-object)
  52.          (cons (type-of kb-object) (kb-kids2list kb-object)))
  53.         ((consp kb-object)
  54.          (mapcar #'kb-tree2list kb-object))
  55.         (t kb-object)))
  56.  
  57. (defun kb-kids2list (kb-object)
  58.   "conses reader-fn and childs into a description list"
  59.   (let ((childs nil)
  60.         (ta (KB-tree-attributes (type-of kb-object))))
  61.     (when ta
  62.       (dolist (reader (the list (first ta)))
  63.         (push (list reader
  64.                     (kb-tree2list (funcall reader kb-object))) childs))
  65.     (nreverse childs))))
  66.  
  67. (defun print-readform (kb-object)
  68.   "prints a kb-object in a readable form"
  69.   (pprint (kb-tree2list kb-object)))
  70.  
  71. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  72. ;;                      End of zebra-debug.lisp
  73. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  74.